package Zim::File;

use strict;
our $VERSION = '0.20';

eval 'use Zim::OS::Win32' if $^O eq 'MSWin32';
die $@ if $@;

our @ISA = ($^O eq 'MSWin32') ? ('Zim::File::Win32')
                              : ('Zim::File::Unix' ) ;

package Zim::File::Unix;

use strict;
use Carp;
use File::Glob ':glob';
use File::Spec;
use File::Copy ();
use File::BaseDir qw/xdg_cache_home/;
use Encode;
use Zim::Events;

require Cwd;

our $VERSION = '0.20';
our @ISA = qw/Zim::Events/;

use overload
	'""' => \&path,
	fallback => 'TRUE' ;

unless (length $ENV{HOME}) {
	my ($home) = bsd_glob('~', GLOB_TILDE);
	$ENV{HOME} = $home if length $home;
}

=head1 NAME

Zim::File - OO wrapper for files

=head1 SYNOPSIS

	$file = Zim::File->new('./Changes');
	$text = $changes."\n\n".$file->read;
	$file->write($text);

=head1 DESCRIPTION

This package provides an object for handling files.
It bundles some snippets of code that are needed by several modules.

Inherits from L<Zim::Events>, supports a "write" event.

=head1 OVERLOAD

This class overloads the '""' operator, so the string version of an object
is the file path.

=head1 METHODS

=over 4

=item C<new(FILENAME)>

Simple constructor, uses L<File::Spec>'s C<catfile> when multiple arguments are given.

=cut

sub new {
	my $class = shift;
	my $name = (@_ == 1) ? shift : File::Spec->catfile(@_);
	croak "Invalid filename: '$name'" unless $name =~ /\S/;
	bless {path => $class->abs_path($name)}, $class;
}

=item C<path>

Returns the full path to the file.

=cut

sub path { $_[0]->{path} }

=item C<file>

Returns the filename part of the path.

=cut

sub file {
	my $self = shift;
	my $file = @_ ? File::Spec->rel2abs($_[0]) : $self->{path};
	my (undef, undef, $name) = File::Spec->splitpath($file);
	return $name;
}

=item C<dir>

Returns the directory part of the path.

=cut

sub dir {
	my $self = shift;
	my $file = @_ ? File::Spec->rel2abs($_[0]) : $self->{path};
	my ($vol, $dir, undef) = File::Spec->splitpath($file);
	return File::Spec->catpath($vol, $dir, '');
}

=item C<read()>

Returns the contents of the file. Takes list context in account.
Returns empty when the file does not exist.

=cut

sub read {
	my $self = shift;
	return unless $self->exists;
	my $fh = $self->open('r');
	my @text = <$fh>;
	$fh->close;
	return wantarray ? (@text) : join('', @text);
}

=item C<read_config(\%CONFIG)>

Read and parses contents.
Returns a hash with key value mappings and a list which indicates the order
in which the keys were found.

The argument CONFIG is optional. If given this hash ref will be used to store
the data.

=cut

sub read_config {
	my $self = shift;
	my $config = shift || {};
	my $order = [];
	for ($self->read) {
		next if /^\s*\#/ || ! /^\s*(.+?)=(.*)$/;
		$$config{$1} = $2 unless defined $$config{$1} and ! length $2;
			# length 0 == undef
		push @$order, $1;
	}
	return wantarray ? ($config, $order) : $config;
}

sub _read_config_alt {
	# New ini-style format to be used for all new files
	my $self = shift;
	my $config = {};
	my $group = $config;
	for ($self->read) {
		/^\s*\#/ and next;
		if (/^\s*\[(.+)\]\s*$/) {
			$$config{$1} ||= {};
			$group = $$config{$1};
		}
		elsif (/^\s*(.+?)\s*=\s*(.+?)\s*$/) {
			$$group{$1} = $2;
		}
	}
	return $config;
}

=item C<read_hash(KEY, CASE)>

Searches for KEY in a plain text hash.
The boolean CASE should be set for case sensitive lookup.
Case insensitive is the default.

=cut

sub read_hash {
	my ($self, $key, $case) = @_;
	$key = $case ? quotemeta($key) : qr/(?i:\Q$key\E)/ ;
	my $value = undef;
	my $fh = $self->open;
	while (<$fh>) {
		/^\s*$key/ or next;
		/^\s*$key\s+(.+?)\s*$/ or next;
		$value = $1;
		last;
	}
	$fh->close;
	return $value;
}

=item C<write(CONTENT, ..)>

Write CONTENT to file.
Creates file and parent directories when needed.

=item C<append(CONTENT, ..)>

Append content to file.
Creates file and parent directories when needed.

=cut

sub write {
	carp "## Zim::File::write: $_[0]";
	unshift @_, 'w';
	goto \&_write;
}

sub append {
	carp "## Zim::File::append: $_[0]";
	unshift @_, 'a';
	goto \&_write;
}

sub _write {
	my $mode = shift;
	my $self = shift;
	$self->make_dir if defined $self->{path};
	my $fh = $self->open($mode);
	print $fh @_;
	$fh->close or die "$!: $self->{path}\n";
}

=item C<write_config(\%CONFIG, \@ORDER)>

Writes a list of keys and values to file.
A second argument can be used to enforce the order of the keys in the
config file; this is optional.

=cut

sub write_config {
	my ($self, $config, $order) = @_;
	$order ||= [sort keys %$config];
	$self->write(map "$_=$$config{$_}\n", @$order);
}

=item C<remove()>

Delete the file.
Removes parent directories when empty.

=cut

sub remove {
	my $self = shift;
	my $file = $self->{path};
	unlink $file or die "Could not delete file: $file\n";
	$self->{mtime} = 0;
	$self->remove_dir;
}

=item C<exists()>

Returns boolean.

=cut

sub exists { -f $_[0]->{path} }

=item C<stat()>

Returns a hash reference with stat values.

=cut

my @stat = qw/dev ino mode nlink uid gid rdev size
		atime mtime ctime blksize blocks/ ;

sub stat {
	my $self = shift;
	my @val = stat $self->{path};
	return { map {$stat[$_] => $val[$_]} 0 .. 12 };
}

=item C<set_mtime()>

Set the mtime for the file as an object attribute.

=item C<check_mtime()>

Get the mtime for the file and compare to stored mtime atribute.
Dies when timestamps do not match. Used by subclasses to detect
when files changed on disk.

=cut

sub set_mtime { $_[0]->{mtime} = (CORE::stat $_[0]->{path})[9] }

sub check_mtime {
	my $self = shift;
	my $file = $self->{path};
	my $mtime ||= (CORE::stat $file)[9];
	die "File has changed on disk since reading: $file\n"
		if  defined $mtime
		and $self->{mtime} != $mtime ;
	$self->{mtime} = $mtime;
}

=item C<open(MODE, FILE)>

Returns an C<IO> object that can be used as a file handle.

Make sure to close this handle using OO syntax, using C<< $fh->close >>
instead of C<close $fh>.

FILE is an optional argument allowing this function to be
used without an object.

MODE can be 'r', 'w' or 'a' for read, write and append respectivly.

=cut

sub open {
	my ($self, $mode, $file) = @_;
	my $cb = ! defined $file;
	$file ||= $self->{path};
	$mode ||= 'r';
	#carp "## Zim::File::open($self, $mode)";
	#carp "Write $self" if $mode eq 'w';

	my $handle = IO::File::Zim->new($file, $mode) || die "$!: $file\n";
	$handle->set_attr(file => $self, mode => $mode) if $cb;
	binmode $handle, ':utf8' unless $] < 5.008;
	
	return $handle;
}

=item C<grep(REGEXP, MODE)>

Line based grep function. MODE can be undefined, 'lines' or 'count';
In normal mode matches are returned, for 'lines' complete lines that
match are returns, and for 'count' a number of matches is returned.

=cut

sub grep {
	my ($self, $regexp, $mode) = @_;
	my $file = $self->{path};
	$mode ||= 'normal';
	return $mode eq 'count' ? 0 : () unless -f $file;
	#print STDERR "Grepping for /$regexp/ in $file (mode: $mode)\n\t";
	my @match;
	my $fh = $self->open;
	if ($mode eq 'lines') {
		while (<$fh>) {
			push @match, $_ if $_ =~ $regexp;
			#print STDERR '.';
		}
	}
	elsif ($mode eq 'count') {
		$match[0] = 0;
		while (<$fh>) {
			$match[0]++ if $_ =~ $regexp;
			#print STDERR '.';
		}
	}
	else {
		$regexp  = /($regexp)/;
		while (<$fh>) {
			push @match, ($_ =~ $regexp);
			#print STDERR '.';
		}
	}
	$fh->close;
	#print STDERR "DONE\n";
	#print STDERR "\t=> @match\n";
	return wantarray ? @match : $match[0] ;
}

=item C<touch()>

Create empty file if file does not exist.

=cut

sub touch {
	my $file = pop;
	carp "## Zim::File::touch: $file";
	return if -e $file;
	Zim::File->make_dir( Zim::File->dir($file) );
	CORE::open FH, '>', $file or die "$!: $file";
	print '';
	close FH;
}

=item C<commit_change()>

If any kind of caching or versioning is done on the storage of this file,
this method will commit all changes. Called automatically by DESTROY.

File objects implementing this should check if there is any actual change
before doing any heavy operation.

=item C<discard_change()>

If any kind of caching or versioning is done on the storage of this file,
this method will discard all changes and reverse to the latest committed
version.

=cut

sub commit_change {}

sub discard_change {}

=back

=head2 Class Methods

The following methods don't need an object to work on. They can also be called
as for example C<< Zim::File->make_dir($dir) >>. Of course they can also be
called on a Zim::File object.

=over 4

=item C<abs_path(NAME, REFERENCE)>

Turn a relative filename or a file uri into a local path name
and cleans up this path to a logical form. It also does tilde 
expansion.

If REFERENCE is omitted the current dir is used.

Calls C<parse_uri()> first when needed.

=cut

sub abs_path {
	my ($class, $file, $ref) = @_;
	#warn "abs_path: $name ($ref)\n";
	$file = $class->parse_uri($file) if $file =~ m#file:/#;
	return $file if $file =~ m#^\w\w+:/#;

	if ($file =~ m#^(~([^/]*))#) {
		my ($home) = length($2) ? bsd_glob($1, GLOB_TILDE) : $ENV{HOME};
		$file =~ s#^(~[^/]*)#$home#;
	}
	elsif ($file !~ m#^/#) {
		$ref ||= Cwd::cwd();
		$file = $ref.'/'.$file;
	}
	
	$file =~ s#(?<=[^/])/+\.(?![^/])##g; # remove /.
	while ($file =~ s#[^/]+/+\.\.(?![^/])##) {} # remove foo/..
	$file =~ s#^(/\.\.)+(?![^/])##; # remove leading /../
	$file =~ s#//+#/#g; # /// => /
	return $file;
}

=item C<rel_path(FILE, REFERENCE, UPWARD)>

Returns a path for FILE relative to REFERENCE
or undef when this is not possible.

When UPWARD is true the returned path can contain
"../", else it will only go below REFERENCE.

=cut

sub rel_path {
	my ($class, $file, $base, $upward) = @_;
	$file = $class->abs_path($file);
	$base = $class->abs_path($base);
	my @file = split '/', $file;
	my @base = split '/', $base;
	return undef if $base[0] ne $file[0];
		# might not even be same volume
	while (@base) {
		last unless $base[0] eq $file[0];
		shift @base;
		shift @file;
	}
	return undef if @base and ! $upward;
	if (@base) { unshift @file, '..' for @base }
	else       { unshift @file, '.'            }
	return join '/', @file;
}

=item C<parse_uri(URI)>

Method for parsing file uris, returns either a normal path or a (new) uri.
No url decoding is done here.

=cut

# support file:/path file://localhost/path and file:///path

sub parse_uri {
	shift; # class
	my $file = shift;
	
	$file =~ m#^file:/# or return $file;
	$file =~ s#^file:(?://localhost/+|/|///+)([^/]+)#/$1#i or return $file;

	return $file;
}

=item C<path2uri(FILE)>

Turns a path into an uri. Does no checks.

=cut

sub path2uri {
	my $class = shift;
	my $file = shift;
	$file = $class->abs_path($file);
	$file =~ s#^/?#file:///#;
	return $file;
}

=item C<cache_path(@PATH)>

Returns a path in the cache.

=cut

sub cache_path {
	my $class = shift;
	my @path = @_; # force copy
	@path = map {
		s/[\/\\:]+/_/g; # win32 save
		s/^_+|_+$//g;
		$_;
	} @path;
	return File::Spec->catfile(xdg_cache_home(), 'zim', @path);
}

=item C<localize(FILE)>

Returns platform dependend version of FILE.

=cut

sub localize {return pop} # default does nothing, placeholder for win32

=item C<copy(SOURCE, DEST)>

Copy content from one file to another.
Creates parent directories if needed.

=cut

sub copy {
	my $self = $_[0];
	
	my $dest = pop;
	my $source = pop;
	$dest = $dest->path if ref $dest;
	$source = $source->path if ref $source;
	croak "Invalid file name: $dest\n" unless $dest =~ /\S/;
	croak "Invalid file name: $source\n" unless $source =~ /\S/;
	
	$self->make_dir($self->dir($dest));
	File::Copy::copy($source, $dest)
		or die "Could not copy '$source' to '$dest' ($!)\n";
}

=item C<move(SOURCE, DEST)>

Move file contents from one place to another.
Takes care of creating and cleaning up parent directories.

=cut

sub move {
	my $self = $_[0];
	
	my $dest = pop;
	my $source = pop;
	$dest = $dest->path if ref $dest;
	$source = $source->path if ref $source;
	croak "Invalid file name: $dest\n" unless $dest =~ /\S/;
	croak "Invalid file name: $source\n" unless $source =~ /\S/;
	
	$self->make_dir($self->dir($dest));
	#warn "moving $source => $dest\n";
	File::Copy::move($source, $dest)
		or die "Could not move '$source' to '$dest'\n";
	$self->remove_dir($self->dir($source));
}

=item C<list_dir(DIR)>

Returns a list of items for DIR. Ignores hidden files.

=cut

sub list_dir {
	my ($self, $dir) = @_;
	$dir = $self->dir if ! defined $dir and ref $self;
	croak "Invalid dir name: $dir" unless $dir =~ /\S/;
	
	opendir DIR, $dir or die "Could not list dir $dir\n";
	my @items = grep {! /^\./} readdir DIR;
	closedir DIR;

	eval {$_ = Encode::decode('utf8', $_, 1)} for @items;
	#warn "$dir =>\n", map "\t$_\n", @items;
	return @items;
}

=item C<grep_dir(DIR, REGEX)>

Returns all items in DIR that match REGEX.

=cut

sub grep_dir {
	my ($self, $dir, $regex) = @_;
	my @matches;
	opendir DIR, $dir or die "Could not open dir: $dir\n";
	while (my $item = readdir DIR) {
		eval { $item = Encode::decode('utf8', $item, 1) };
		push @matches, $item if $item =~ $regex;
	}
	closedir DIR;
	return @matches;
}

=item C<make_dir(DIR)>

Create DIR is it doesn't exist already. Subtle differences with L<File::Path>.

=cut

sub make_dir {
	my ($self, $dir) = @_;
	$dir = $self->dir if ! defined $dir and ref $self;
	croak "Invalid dir name: $dir" unless $dir =~ /\S/;
	
	return if -d $dir;
	
	my ($vol, $dirs) = File::Spec->splitpath(
		File::Spec->rel2abs($dir), 'DIR');
	my @dirs = File::Spec->splitdir($dirs);
	my $path = File::Spec->catpath($vol, shift @dirs, '');
	mkdir $path or die "Could not create dir: $path\n"
		unless ! length $path or -d $path;
	while (@dirs) {
		$path = File::Spec->catdir($path, shift @dirs);
		mkdir $path or die "Could not create dir $path\n"
			unless -d $path;
	}
}

=item C<remove_dir(DIR)>

Removes a directory and it's parents when they are empty.
Fails silently.

=cut

sub remove_dir {
	my ($self, $dir) = @_;
	$dir = $self->dir if ! defined $dir and ref $self;
	croak "Invalid dir name: $dir" unless $dir =~ /\S/;
	
	rmdir $dir or return; # fails when non-empty
	
	my ($vol, $dirs) = File::Spec->splitpath(
		File::Spec->rel2abs($dir), 'DIR');
	my @dirs = File::Spec->splitdir($dirs);
	while (@dirs) {
		pop @dirs;
		$dir = File::Spec->catdir($vol, @dirs);
		#warn "rmdir $dir\n";
		rmdir $dir or last; # fails when non-empty
	}
}

=item C<resolve_file(\%OPT, $ROOT, @PARTS)>

Look for a file below ROOT that kind of looks like @PARTS.
Options that can be passed in %OPT include:

=over 4

=item ext

File extension to add to the last part when resolving a file.

If a dir does not exist we try a file with this extension to resolve
the right case.

=item is_dir

We are looking for a dir.

=back

=cut

sub resolve_file {
	my ($class, $opt, $path, @parts) = @_;
	#warn "Resolve file: $path @parts\n";

	while (@parts) {
		my $part = shift @parts;
		my $match;
		if (-d $path) {
			my $is_file = (! @parts and ! $$opt{is_dir});
			$match = _grep_match($class, $path, $part, $$opt{ext}, $is_file);
		}
		if (defined $match) {
			#warn "\t$part => $match\n";
			$path .= '/' . $match;
		}
		else {
			$path = join '/', $path, $part, @parts;
			$path .= '.' . $$opt{ext} if ! $$opt{is_dir} and length $$opt{ext};
			last;
		}
	}

	#warn "\t=>$path\n";
	return $path;
}

sub _grep_match {
	my ($class, $path, $part, $ext, $is_file) = @_;
	my $regex = length($ext)
		? qr/^(?i:\Q$part\E)(?:$|\.$ext$)/
		: qr/^(?i:\Q$part\E)(?:$|\.)/  ;
	my @matches = $class->grep_dir($path, $regex);
	return undef unless @matches;

	if ($is_file and length $ext) { # prefer with extension
		my $f = $part . '.' . $ext;
		my @m = grep /\.\Q$ext\E$/, @matches;

		if (@m) {
			return $f if grep {$_ eq $f} @m;
			@m = sort @m;
			return $m[0];
		}
		else {
			return $f if grep {$_ eq $part} @matches;
			@matches = sort @matches;
			return $matches[0] . '.' . $ext;
		}
	}
	else {
		return $part if grep {$_ eq $part} @matches;

		@matches = sort @matches;
		return substr($matches[0], 0, length $part);
	}

	return undef;
}

sub DESTROY { goto \&commit_change }



=back

=head1 SUBCLASSES

=cut


package Zim::File::CheckOnWrite;

use strict;

our @ISA = qw/Zim::File/;

=head2 Zim::File::CheckOnWrite

This subclass is used for the text files containing
pages to prevent data loss.

Be aware that checking and locking done in this class are only
intended to prevent a single user to overwrite data by accident.
It will not suffice for a multi-user system.

This class checks the modification time of the file when
reading and writing. It will not allow you to overwrite a file
if it changed since you read it.

Also this class implements "atomic" writing. This means that
when you write to a file you write to a temporary file first.
When the file handle is closed the temporary file is moved to
replace the original file. This way the original file is not
purged when an error occurs while writing.

=cut

sub new {
	my $class = shift;
	my $self = $class->SUPER::new(@_);
	$self->{mtime} = 0;
	$self->{tmp_path} = $self->{path} . '.new~';
	$self->signal_connect('write', \&on_write);
	return $self;
}

sub on_write {
	# rename tmp file to real path and record mtime
	my $self = shift;
	#warn "move $self->{tmp_path} => $self->{path}\n";
	File::Copy::move($self->{tmp_path} => $self->{path})
		or die "Could not move '$$self{tmp_path}' to '$$self{path}'\n";
	$self->set_mtime;
}

sub open {
	my ($self, $mode) = @_; 
	$mode ||= 'r';
	
	($mode eq 'r') ? $self->set_mtime : $self->check_mtime ; # mode 'w' || 'a'

	if ($mode eq 'r') {
		return $self->SUPER::open($mode);
	}
	else { # mode 'w' || 'a'
		# open tmp file but connect callback for write
		my $handle = $self->SUPER::open($mode, $self->{tmp_path});
		$handle->set_attr(file => $self, mode => $mode);
		return $handle;
	}
}



package Zim::File::CacheOnWrite;

use strict;

our @ISA = qw/Zim::File/;

=head2 Zim::File::CacheOnWrite

This subclass is used when the original file is located on a slow
file system. It implements a "copy on write" that uses a cache file
after the first write. You need to call C<commit_change()> in order
to overwrite the original file.

It does check the modification time like CheckOnWrite.

=over 4

=item C<set_cache(PATH)>

Set the file name to use as cache.

=cut

sub new {
	my $class = shift;
	my $self = $class->SUPER::new(@_);
	$self->{mtime} = 0;
	$self->{cache_path} = $self->cache_path($self->{path});
	#warn "path: $self->{path}\ncache_path: $self->{cache_path}\n";
	if (-f $self->{cache_path}) { # file exists - get original mtime
			my $mtime = Zim::File->new($self->{cache_path}.'.mtime')->read();
			chomp $mtime;
			$self->{mtime} = $mtime || 0;
	}
	$self->signal_connect('write', \&on_write);
	return $self;
}

sub on_write { $_[0]->set_mtime }

sub open {
	my ($self, $mode) = @_;
	$mode ||= 'r';

	my $cache = $self->{cache_path};
	die "BUG: no cache path set" unless $cache;
	#warn "open $mode cache: $cache, exists: ".(-f $cache)."\n";
	
	if ($mode eq 'r' and ! -f $cache) {
		$self->set_mtime;
		return $self->SUPER::open($mode);
	}
	# else cache exists or mode 'w' or 'a'
	
	$self->make_dir( $self->dir($cache) ) if $mode eq 'w';
	Zim::File->new($cache.'.mtime')->write($self->{mtime});
	return Zim::File->open($mode, $cache);
		# no "write" event call back with this syntax
		# therefore no mtime hook here
}

=item C<commit_change()>

Copy the cached data back to the original file.

=cut

sub commit_change {
	my $self = shift;
	return unless -f $self->{cache_path};
	
	$self->check_mtime;

	warn "## move $self->{path} => $self->{cache_path}\n";
	my $out = $self->SUPER::open('w');
	my $in = Zim::File->open('r', $self->{cache_path});
	File::Copy::copy($in => $out)
		or die "Could not copy '$$self{cache_path}' to '$$self{path}'\n";
	$in->close;
	$out->close; # will trigger "write" event

	$self->discard_change();
}

=item C<discard_change()>

Throw away the cached version.

=cut

sub discard_change {
	return unless -f $_[0]->{cache_path};
	unlink $_[0]->{cache_path}
		or die "$!: $_[0]->{cache_path}\n";
	unlink $_[0]->{cache_path}.'.mtime';
}



package IO::File::Zim;

use strict;
use IO::File;

our @ISA = qw/IO::File/;

# This class is a hack in order to provide a callback
# when the filehandle is closed. This is needed to fix
# stuff like saving the 'mtime' _after_ the file was writen.

# It uses a global hash to save object attributes because
# IO::Handle objects are filehandle references, not hashes.

# It uses a indirect subroutine definition to circumvent
# the Pod::Cover test

our %_objects;

*set_attr = sub { # used to set object attributes
	my $fh = shift;
	$_objects{"$fh"} = {@_};
};

*close = sub {
	my $fh = shift;
	my $re = $fh->SUPER::close(@_);
	return $re unless exists $_objects{"$fh"};
	my $obj = delete $_objects{"$fh"};
	$$obj{file}->signal_emit('write') if $$obj{mode} eq 'w';
	return $re;
};

*DESTROY = sub {
	my $fh = shift;
	return unless exists $_objects{"$fh"};
	my $obj = delete $_objects{"$fh"};
	return unless $$obj{mode} eq 'w';
	warn "File handle not closed after writing for:\n\t$$obj{file}\n";
	# We do not trigger the signal here - close might not have
	# happened due to an error while writing atomically.
};

1;

__END__

=back

=head1 AUTHOR

Jaap Karssenberg (Pardus) E<lt>pardus@cpan.orgE<gt>

Copyright (c) 2006 Jaap G Karssenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<Zim>

=cut

